home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / CGIshell 1.3.2 / shell / field.4th next >
Encoding:
Text File  |  1996-04-23  |  5.9 KB  |  206 lines  |  [TEXT/ALFA]
  1. \
  2. \
  3. \  PF Forms Handler:   Fields  --  version 1.3.2
  4. \
  5. \
  6. \  (c) Ronald T. Kneusel, 1995, 1996
  7. \  (rkneusel@post.its.mcw.edu)
  8. \
  9. \  This code may be used and distributed freely provided the copyright 
  10. \  notice remains intact and my name is mentioned in the documentation.
  11. \
  12. \  Last mod: 23-Apr-96
  13. \  =========================================================================
  14. \
  15. \  These are the new field definition words.
  16. \
  17. \  It assumes these files to be already loaded:
  18. \
  19. \    server.4th  -  web server interface
  20. \    string.4th  -  string words
  21. \
  22. \
  23. \  Field record:
  24. \
  25. \  +----+--------+-----------+---------------+
  26. \  |type| name   | value ... | text ........ |
  27. \  +----+--------+-----------+---------------+
  28. \
  29. \  where:
  30. \
  31. \    type  (1 byte)       =  0 STR, 1 INT, 5 FP
  32. \    name  (30 bytes)     =  null terminated text of field name
  33. \    value (0,2,10 bytes) =  value of field, for STR is same as start of text, 
  34. \                            2 bytes for INT, 10 bytes for FP
  35. \    text  (varies)       =  text string of value, i.e. INT is 2 then text is "2"
  36. \
  37. \  
  38. \  Object:
  39. \
  40. \    Identical to field record but not entered in field array.
  41. \
  42.  
  43. \ *** None of these words check for overflow or error conditions!  Memory is 
  44. \     at a premium, so you, the programmer, are on your own!
  45.  
  46.  
  47. \ Misc support words
  48.  
  49. : notvalid? ( c -- t|f ) \ true if c not a valid number character
  50.    dup 45 = IF drop 0 exit THEN  \ is it '-'?
  51.    dup 46 = IF drop 0 exit THEN  \ '.'
  52.    dup 43 = IF drop 0 exit THEN  \ '+'
  53.    dup 69 = IF drop 0 exit THEN  \ 'E'
  54.    dup 101 = IF drop 0 exit THEN \ 'e'
  55.    dup 47 > swap 58 < and IF 0 exit THEN  \ '0' through '9'
  56.    -1  \ something else
  57. ;
  58.  
  59. : ok? ( s -- s t|f )  \ true if string a valid number
  60.    dup c@ 0= IF 0
  61.    ELSE  \ not null
  62.      dup dup dup length + swap
  63.      DO
  64.        r c@ notvalid? IF
  65.         0 10000 ELSE 1 THEN
  66.      +LOOP  dup 0= IF ( 0 ) ELSE -1 THEN
  67.    THEN
  68. ;
  69.  
  70. variable #digits   \ holds number of significant digits
  71. 6 #digits !        \ default to 6 digits
  72. : f< ( f1 f2 -- f1<f2 ) fcompare >r fdrop fdrop r> -1 = ;
  73. : f> ( f1 f2 -- f1>f2 ) fcompare >r fdrop fdrop r>  1 = ;
  74. : pp ( f -- f )  \ set the output number format
  75.    fdup fabs fdup
  76.    0.009 f> >r  100000.0 f< r> and
  77.    IF  #digits @ fix  ELSE  #digits @ sci  THEN ;
  78.  
  79.  
  80. \ Data types
  81.  
  82. 0 constant STR    \ string
  83. 1 constant INT    \ integer
  84. 5 constant FP     \ floating point
  85.  
  86. \ Record access
  87.  
  88. : .type ( r -- t )  c@ ;      \ return data type
  89. : .name ( r -- a )  1+ ;      \ return address of field name
  90.  
  91. : .val  ( r -- a )  31 + ;    \ return *address* of value
  92.  
  93. : @val ( r -- v )  \  return *value* of field, addr if STR
  94.   dup >r .val r> c@
  95.   dup STR = IF  drop      ELSE  \ STR
  96.   dup INT = IF  drop  @   ELSE  \ INT
  97.   dup FP  = IF  drop  f@  ELSE  \ FP
  98.   drop drop 0 THEN THEN THEN  \ error
  99. ;
  100.  
  101.  
  102. : $%int ( r+31 -- )  \ take int value and put in text area as a string
  103.   dup 2+ >r  @ 0 d>f 0 fix r> f>str ;
  104.  
  105. : $%fp  ( r+31 -- )  \ take fp value and put in text area as a string
  106.   dup 10 + >r  f@ pp r> f>str ;
  107.  
  108. : !val ( v r -- )  \ put the value, by type, in the record
  109.   dup >r .val r> c@
  110.   dup STR = IF  drop dup 0 swap c! strcpy  ELSE  \ STR, copy string
  111.   dup INT = IF  drop dup >r ! r> $%int    ELSE   \ INT
  112.   dup FP  = IF  drop dup >r f! r> $%fp    ELSE   \ FP
  113.   drop drop THEN THEN THEN     \ error
  114. ;
  115.  
  116. : .text ( r -- a )  \ return the *address* of the field text
  117.   dup c@
  118.   dup STR = IF  drop 31 +  ELSE \ STR
  119.   dup INT = IF  drop 33 +  ELSE \ INT
  120.   dup FP  = IF  drop 41 +  ELSE \ FP
  121.   drop drop 0 THEN THEN THEN  \ error
  122. ;
  123.  
  124.  
  125. \ Template and Field array words
  126.  
  127. create (T)  50 2* allot   \ template array
  128. create (F)  50 2* allot   \ field array
  129.  
  130. variable #T#  0 #T# ! \ template array index
  131. variable #F#  0 #F# ! \ field array index
  132.  
  133. : >table ( r_addr -- )  \ enter record in the table
  134.   #T# @ 2* (T) + !  #T# @ 1+ #T# ! ;
  135.  
  136. : >field ( r_addr -- )  \ enter record in the field array
  137.   #F# @ 2* (F) + !  #F# @ 1+ #F# !  ;
  138.  
  139. : @(T) ( idx -- addr )  2* (T) + @ ;
  140. : @(F) ( idx -- addr )  2* (F) + @ ;
  141.  
  142.  
  143. \ Define a field record
  144.  
  145. 30 $variable @#$
  146. : " ( string -- ) \ assign text to a string from the input stream.
  147.     @#$ 34 word  here >null  here swap $copy ;
  148.  
  149. : #FIELD \ define a field record
  150.   CREATE  here >r swap dup >r  2* + 31 + allot  
  151.   ( compiling: type text-size -- addr )
  152.   r> ( type)  r> ( addr)
  153.   2dup c!  ( set type )
  154.   swap drop dup >r 1+  @#$ swap  strcpy  ( set name)
  155.   r  >table ( enter in template array)
  156.   r> >field ; ( enter in fields array)
  157.   ( runtime:  -- addr )
  158.  
  159.  
  160. \
  161. \ E.g.  A floating point field 15 characters long named HEIGHT is defined as:
  162. \
  163. \  FP 15 " height" #FIELD height
  164. \
  165.  
  166. : #OBJECT \ define an object
  167.   CREATE  here >r swap dup >r  2* + 31 + allot  
  168.   ( compiling: type text-size -- addr )
  169.   r> ( type)  r> ( addr)
  170.   2dup c!  ( set type )
  171.   swap drop dup >r 1+  @#$ swap  strcpy  ( set name)
  172.   r>  >table ; ( enter in template array)
  173.   ( runtime:  -- addr )
  174.  
  175. \
  176. \ E.g.  A floating point object 15 characters long named WIDTH is defined as:
  177. \
  178. \  FP 15 " width" #OBJECT width
  179. \
  180.  
  181.  
  182.  
  183. \ Initialize the fields
  184.  
  185. : <<int ( idx -- )  \ put the integer string in the integer part
  186.   @(F) dup 33 +  ok? IF str>f f>d drop ELSE 0 THEN  swap 31 + ! ;
  187.  
  188. : <<fp  ( idx -- )  \ put the float string in the float part
  189.   @(F) dup >r 41 +  ok? IF str>f ELSE 0.0 THEN  r> 31 + f! ;
  190.  
  191. : <getFields> ( -- )  \ get the fields from the Apple Event and initialize
  192.   #F# @ 0 DO                           \ for each field
  193.     r @(F) 1+                          \    get the name
  194.     r @(F) .text swap NEW              \    and the target 
  195.     @Field                             \    fill in the initial string value
  196.     r @(F) c@                          \    get the type
  197.     dup 0=  IF  drop           ELSE    \      STR, nothing to do
  198.     dup 1 = IF  drop  r <<int  ELSE    \      INT, get integer from string
  199.     dup 5 = IF  drop  r <<fp   ELSE    \      FP, get float from string
  200.     drop THEN THEN THEN
  201.   LOOP                                 \ move to the next field
  202. ;
  203.  
  204.  
  205. \ on to template.4th...
  206.